home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / cltime.scm < prev    next >
Text File  |  1999-04-19  |  2KB  |  68 lines
  1. ;;;; "cltime.scm" Common-Lisp time conversion routines.
  2. ;;; Copyright (C) 1994, 1997 Aubrey Jaffer.
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (require 'values)
  21. (require 'time-zone)
  22. (require 'posix-time)
  23.  
  24. (define time:1900 (time:invert time:gmtime '#(0 0 0 1 0 0 #f #f 0 0 "GMT")))
  25.  
  26. (define (get-decoded-time)
  27.   (decode-universal-time (get-universal-time)))
  28.  
  29. (define (get-universal-time)
  30.   (difftime (current-time) time:1900))
  31.  
  32. (define (decode-universal-time utime . tzarg)
  33.   (let ((tv (apply time:split
  34.            (offset-time time:1900 utime)
  35.            (if (null? tzarg)
  36.                (tz:params utime (tzset))
  37.                (list 0 (* 3600 (car tzarg)) "???")))))
  38.     (values
  39.      (vector-ref tv 0)            ;second    [0..59]
  40.      (vector-ref tv 1)            ;minute    [0..59]
  41.      (vector-ref tv 2)            ;hour    [0..23]
  42.      (vector-ref tv 3)            ;date    [1..31]
  43.      (+ 1 (vector-ref tv 4))        ;month    [1..12]
  44.      (+ 1900 (vector-ref tv 5))        ;year    [0....]
  45.      (modulo (+ -1 (vector-ref tv 6)) 7) ;day-of-week    [0..6] (0 is Monday)
  46.      (eqv? 1 (vector-ref tv 8))        ;daylight-saving-time?
  47.      (if (provided? 'inexact)
  48.      (inexact->exact (/ (vector-ref tv 9) 3600))
  49.      (/ (vector-ref tv 9) 3600))    ;time-zone    [-24..24]
  50.      )))
  51.  
  52. (define (encode-universal-time second minute hour date month year . tzarg)
  53.   (let* ((tz (if (null? tzarg)
  54.          (tzset)
  55.          (time-zone (string-append
  56.                  "???" (number->string (car tzarg))))))
  57.      (tv (vector second
  58.              minute
  59.              hour
  60.              date
  61.              (+ -1 month)
  62.              (+ -1900 year)
  63.              #f            ;ignored
  64.              #f            ;ignored
  65.              )))
  66.     (difftime (time:invert localtime tv) time:1900)))
  67.  
  68.